home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / cmpaux.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  2.4 KB  |  167 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     cmpaux.c
  10. */
  11.  
  12. #include "include.h"
  13.  
  14. siLspecialp()
  15. {
  16.     object sym;
  17.  
  18.     check_arg(1);
  19.     sym = vs_base[0];
  20.     if (type_of(sym) == t_symbol &&
  21.         (enum stype)sym->s.s_stype == stp_special)
  22.         vs_base[0] = Ct;
  23.     else
  24.         vs_base[0] = Cnil;
  25. }
  26.  
  27. init_cmpaux()
  28. {
  29.     make_si_function("SPECIALP",siLspecialp);
  30. }
  31.  
  32.  
  33. int
  34. ifloor(x, y)
  35. int x, y;
  36. {
  37.     if (y == 0)
  38.         FEerror("Zero divizor", 0);
  39.     else if (y > 0)
  40.         if (x >= 0)
  41.             return(x/y);
  42.         else
  43.             return(-((-x+y-1))/y);
  44.     else
  45.         if (x >= 0)
  46.             return(-((x-y-1)/(-y)));
  47.         else
  48.             return((-x)/(-y));
  49. }
  50.  
  51. int
  52. imod(x, y)
  53. int x, y;
  54. {
  55.     return(x - ifloor(x, y)*y);
  56. }
  57.  
  58. set_VV(VV, n, data)
  59. object VV[];
  60. int n;
  61. object data;
  62. {
  63.     object *p, *q;
  64.  
  65.     p = VV;
  66.     q = data->v.v_self;
  67.     while (n-- > 0)
  68.         *p++ = *q++;
  69.     data->v.v_self = VV;
  70. }
  71.  
  72. /*
  73.     Conversions to C
  74. */
  75.  
  76. char
  77. object_to_char(x)
  78. object x;
  79. {
  80.     int c;
  81.  
  82.     switch (type_of(x)) {
  83.     case t_fixnum:
  84.         c = fix(x);  break;
  85.     case t_bignum:
  86.         c = x->big.big_car;  break;
  87.     case t_character:
  88.         c = char_code(x);  break;
  89.     default:
  90.         FEerror("~S cannot be coerce to a C char.", 1, x);
  91.     }
  92.     return(c);
  93. }
  94.  
  95. int
  96. object_to_int(x)
  97. object x;
  98. {
  99.     int i;
  100.  
  101.     switch (type_of(x)) {
  102.     case t_character:
  103.         i = char_code(x);  break;
  104.     case t_fixnum:
  105.         i = fix(x);  break;
  106.     case t_bignum:
  107.         i = x->big.big_car;  break;
  108.     case t_ratio:
  109.         i = number_to_double(x);  break;
  110.     case t_shortfloat:
  111.         i = sf(x);  break;
  112.     case t_longfloat:
  113.         i = lf(x);  break;
  114.     default:
  115.         FEerror("~S cannot be coerce to a C int.", 1, x);
  116.     }
  117.     return(i);
  118. }
  119.  
  120. float
  121. object_to_float(x)
  122. object x;
  123. {
  124.     float f;
  125.  
  126.     switch (type_of(x)) {
  127.     case t_character:
  128.         f = char_code(x);  break;
  129.     case t_fixnum:
  130.         f = fix(x);  break;
  131.     case t_bignum:
  132.     case t_ratio:
  133.         f = number_to_double(x);  break;
  134.     case t_shortfloat:
  135.         f = sf(x);  break;
  136.     case t_longfloat:
  137.         f = lf(x);  break;
  138.     default:
  139.         FEerror("~S cannot be coerce to a C float.", 1, x);
  140.     }
  141.     return(f);
  142. }
  143.  
  144. double
  145. object_to_double(x)
  146. object x;
  147. {
  148.     double d;
  149.  
  150.     switch (type_of(x)) {
  151.     case t_character:
  152.         d = char_code(x);  break;
  153.     case t_fixnum:
  154.         d = fix(x);  break;
  155.     case t_bignum:
  156.     case t_ratio:
  157.         d = number_to_double(x);  break;
  158.     case t_shortfloat:
  159.         d = sf(x);  break;
  160.     case t_longfloat:
  161.         d = lf(x);  break;
  162.     default:
  163.         FEerror("~S cannot be coerce to a C double.", 1, x);
  164.     }
  165.     return(d);
  166. }
  167.